=head1 NAME

Guile::Space - Guile Code Execution Environment

=cut

package Guile::Space;
use warnings;
use strict;

use Moose;
use Carp;
use Guile;
use aliased 'Guile::Space::Result';
use aliased 'Guile::Space::Value';
use Scalar::Util qw(looks_like_number);

BEGIN {
    if ( $ENV{GUILE_LOAD_PATH} ) {
        my @paths = split /:/, $ENV{GUILE_LOAD_PATH};
        my $paths = ( join ' ', map { qq("$_") } @paths ) || "'()";
        my $set   = "(set! \%load-path (list $paths))";
        Guile::eval_str($set);
    }
}

=head1 SYNOPSIS

  use Guile::Space;
  my $space = Guile::Space->new;

  my $x = $space->run( code  => '(+ foo bar)', 
                       scope => { foo => 1, bar => 2 } );

=head1 DESCRIPTION

This module uses L<Guile> and L<Inline::Guile> to provide an execution
environment for the guile scheme language, with the option of retrieving
values from perl space.

B<Note however>, that the other way, passing perl values back to perl 
space, does not work yet.

=head2 Basic Usage

You can use the C<run> method to pass code snippets to be evaluated into
the guile space. All values that are provided with the C<scope> hash
reference will be passed directly if they are simple enough, or 
transformed into callbacks into perl space if they are more complex
values.

  $space->run( code  => '(+ 1 2)'
               scope => { foo => 23,                # passed as-is          
                          bar => "Fnord",           # passed as-is
                          boo => undef,             # passed as #f
                          baz => { x => 1, y => 2 } # callback
                        });

=head2 Closures

Closures can be called in guile space like regular scheme procedures:

  # $x is "foo, 23, bar"
  my $x = $space->run( code  => '(perljoin ", " "foo" 23 "bar")',
                       scope => { perljoin => sub { join shift, @_ } } );

=head2 Objects

To call an object method, pass the method name as the first argument. The
rest is seen as arguments to the method:

  ... (object 'method arg1 arg2) ...

=head2 Hashes

Hashes can be read and manipulated:

  ... (set! foo (my-hash 'get 'foo)) ...
  ... (my-hash 'set 'foo 23) ...

Two other methods can be used to get a transformed perl array of keys and
values:

  ... (set! foo-keys  (foo 'keys)) ...
  ... (set! foo-vals1 (foo 'values)) ...
  ... (set! foo-vals2 (foo 'values-of 'bar 'baz)) ...

The C<values-of> method returns only the values of the keys matching it's
following arguments.

You will often want to use this kind of object like a regular guile hash.
For this you can use the C<to-hash> method:

  ... (set! guile-hash (my-hash 'to-hash)) 
      (display (hashq-ref guile-hash 'foo))
      (newline) ...

=head2 Arrays

Arrays work pretty similar to hashes:

  ... (set! foo (my-array 'get 1)) ...
  ... (my-array 'set 0 "Foo") ...

The index of the last element and the arrays size can be obtained like 
this:

  ... (set! my-ary-size (my-array 'size)) ...
  ... (set! my-ary-last (my-array 'last)) ...

To use this structure directly in guile, use the C<to-list> method to
create a simple guile list out of it's elements:

  ... (apply + (my-array 'to-list)) ...

=head1 METHODS

=cut

our $VERSION = 0.01;

#
#   Does the catching of the callback hooks
#
has 'wrapper',
    is          => 'rw',
    default     => sub { Guile::lookup( 'perl-horizon-wrapper' ) },
    ;

#
#   this fellow transforms perl scalars into their respective guile
#   counterparts. Much less hassle than doing string construction
#   ourselves.
#
has '_transformer',
    is          => 'rw',
    default     => sub { Guile::lookup( 'perl-to-guile-transform' ) },
    ;

#
#   main entry point for every call.
#
our %named_values = (
    'make-perl-hash'    => sub { return {} },
    'make-perl-array'   => sub { return [] },
);
our @anonymous_values;
sub run {
    my ( $self, %args ) = @_;
    my %predefined = %named_values;

    #   we localize the bound value storage for this call
    local %named_values;
    local @anonymous_values;

    #   we put the scoped values around our code in a let construct
    #   so the guile code can refer to it by name
    $args{scope} ||= {};
    $args{scope} = { %predefined, %{$args{scope}} };
    $args{scope} = $self->_prepare_values( $args{scope} );
    my $code = $self->_scope_values( $args{code}, $args{scope} );
    debug( "Scoped Code:\n$code" );
    
    #   start the initial callback cycle with our wrapper.
    my $result_value = $self->_callback_cycle(
        sub { $self->wrapper->( $code ) }
    );

    #   return the resulting value of the operation.
    return $result_value;
}

=head2 run

  $space->run( code => $guile_code, scope => \%bindings );

=cut

#
#   transform possible complex value to callback code
#
sub _prepare_values {
    my ( $self, $values ) = @_;
    $values = {%{ $values }};

    #   run every value through our preparation routine, so that they can
    #   be transformed in a state that guile can understand, if needed.
    for my $name (keys %$values) {
        $values->{ $name } = $self->_prepare_single_value( 
            $name => $values->{ $name } );
    }

    return $values;
}

sub _prepare_single_value {
    my ( $self, $name, $value, $transf ) = @_;
    my $debug_prefix = ( $name ? $name : '<anon>' ) . ": ";
    debug( $debug_prefix . 'Will ' . ( $transf ? '' : 'not ' ) . 'be transformed' );

    #   undefined values are represented with a boolean false
    return ( $transf ? Guile::eval_str('#f') : '#f' ) 
        unless defined $value;

    #   scalarrefs are passed as they are
    return $$value if ref $value eq 'SCALAR';

    #   if the value is not a reference, or just a Guile::SCM, we don't 
    #   store it and produce a callback, it can be passed directly.
    debug( $debug_prefix . 'Value is defined' );
    if ( not ref $value or ( !$name and ref $value eq 'Guile::SCM' ) ) {
        return $self->_transformer->( $value ) 
            if not $transf and ( not ref $value eq 'Guile::SCM'
                                  or not looks_like_number( $value ) );
        return $value;
    }
        
    #   a reference value is more complicated, we create a container for it
    #   to store it on our side
    debug( $debug_prefix . 'Value is a reference' );
    my $container = Value->new(
        original_value  => $value,
        guile_space     => $self,
    );
    my $type;

    #   named values are only encountered on first round when they're passed
    #   to the run method. we just store them by their name.
    if ( $name ) {
        $named_values{ $name } = $container;
        $type = 'named';
        debug( "Named container '$name' stored" );
    }

    #   values that are created by those callbacks are called anonymous and
    #   are stored by index.
    else {
        push @anonymous_values, $container;
        $type = 'anonymous';
        $name = $#anonymous_values;
        debug( "Anonymous value container stored under index $name" );
    }
    
    #   the stored values are represented as lambdas in guile-space. these 
    #   throw exceptions containing continuations, to continue the execution
    #   at the place the execution was requested.
    my $lambda = 
        "(lambda args (perl-horizon-jump '$type '$name args))";
    return ( $transf ? Guile::eval_str($lambda) : $lambda );
}

#
#   This is just there to find the container of a specified type. It's
#   a common thing we might need.
#
sub fetch_container {
    my ( $self, %args ) = @_;
    return $named_values{ $args{name} }     if $args{type} eq 'named';
    return @anonymous_values[ $args{name} ] if $args{type} eq 'anonymous';
}

#
#   the callback cycle functionality. this evaluates jumps and manages
#   reentries.
#
sub _callback_cycle {
    my ( $self, $entry_point, @args ) = @_;

    #   The call cycles will be continued until a final value is found,
    #   or, of course, an error occurs. They enter the guilespace at
    #   a specified entrypoint and pass arguments to it. They then 
    #   receive a result structure which determines the next actions.
  CYCLE:
    while (1) {
        debug( "\n+---< Cycle Start >---+" );
    
        #   we pack the entry points return value in a result, so it
        #   can be evaluated by the container, which is mostly a
        #   convenient interface for the complex return value structure.
        my $result = Result->new( 
            value       => $entry_point->( @args ),
            guile_space => $self,
        );

        #   this was the final round as the call told us this is the
        #   final value that is to be returned to the callee.
        if ( $result->is_final ) {
            debug( 'Final Result' );
            return $result->final_value;
        }

        if ( $result->is_exception ) {
            debug( 'Exception caught' );
            croak 'Exception caught in guile-space: ' . $result->exception_key
                . ' (' . $result->exception_msg . ')';
        }

        #   set the entrypoint and arguments for the next iteration step
        @args        = $result->execute_callback;
        $entry_point = $result->continuation;
        #debug( "Callback Returned: @args" );

        #   transform the next value into it's guile representation
        @args = $self->_prepare_single_value( undef, $args[0], 1 );
    }    
}

#
#   build a scope around a code block, so we can access values by their
#   name.
#
sub _scope_values {
    my ( $self, $code, $values ) = @_;

    #   encapsulate the code in a 'let' construct that provides
    #   it with the named callback procedures.
    return '(begin '
        . join( "\n       ",
            map { "(define $_ @{[$values->{ $_ }]})" } keys %$values )
        . "\n       $code)";
}

#
#   print the message to STDOUT if the debugging env var is set.
#
sub debug {
    my ( $msg ) = @_;
    warn "$msg\n" if $ENV{ GUILE_SPACE_DEBUG };
}

#
#   we need some code in the guile space that is compile time defined.
#
use Inline Guile => q(

; Transform perl data into it's guile representation
  (define perl-to-guile-transform
    (lambda (p) 
      (with-output-to-string (lambda () 
                               (write p)))))

; I don't really know if we really need this, but mst did it, so I'll just
; adapt cargo-style.
  (define call/cc call-with-current-continuation)

; Callback into Perl Space
  (define perl-horizon-jump (lambda p
    (call/cc (lambda (k) ( (throw 'perl-horizon-jump k p ))))))

; This makes the callbacks possible
  (define perl-horizon-wrapper
    (lambda (expr)
      (catch #t
             (lambda ()
               (catch 'perl-leave-horizon-space
                      (lambda ()
                        (catch 'perl-horizon-jump
                               (lambda () (throw 'perl-leave-horizon-space
                                 (eval-string expr)))
                               (lambda (key k p) (list key k p))))
                      (lambda (key p)
                        (list key p))))
             (lambda (key . args)
               (list 'guile-space-exception key args)))))

);

1;
